home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / drdobbs / 1991 / 06 / fortran.asc < prev    next >
Text File  |  1991-05-02  |  7KB  |  243 lines
  1. _FORTRAN & GUIS_
  2. by John L. Bradberry
  3.  
  4. [LISTING ONE]
  5.  
  6. C    >**************************************************************
  7.       PROGRAM BELL
  8. C     **************************************************************
  9. C     AUTHOR: JOHN L. BRADBERRY         CREATION DATE: FEB 15,1989
  10. C     UTILITY TO CREATE A BELL CURVE DATA 'PLOT' BY READING IN A SERIES 
  11. C     OF NUMBERS IN THE RANGE OF 0-100. THE NUMBERS ARE USED TO CREATE
  12. C     THE GAUSSIAN DISTRIBUTION CONSTANTS. THE CONSTANTS ARE THEN USED TO
  13. C     CALCULATE A NORMAL DISTRIBUTION FROM 0 TO 100 IN STEPS OF 5. '*' ARE
  14. C     PLOTTED IN HISTOGRAM FORM TO SIMULATE BELL SHAPE.
  15. C     --------------------------------------------------------------
  16. C
  17.       IMPLICIT NONE
  18. C
  19.       INCLUDE 'BELLCOM.INC'
  20. C
  21. C
  22.       INTEGER*2         LU              !LOGICAL UNIT NUMBER
  23. C      
  24.       LU=6
  25. C
  26. C     INITIALIZE BELL CURVE DATA (CONTAINED IN COMMON)...
  27. C
  28.       BCIDX=0
  29.       BCTOT=0
  30.       BCEX=0
  31.       BCEXS=0
  32.       
  33.  
  34. C     GET BELL CURVE VALUES FROM USER TO BE USED FOR CALCULATIONS...
  35. C
  36.       CALL GET_BELL_DATA(LU)
  37. C
  38. C     CALCULATE CONSTANTS FOR GAUSSIAN DISTRIBUTION AND PLOT BELL CURVE
  39. C     USING THE '*' CHARACTER...
  40. C
  41.       CALL PLOT_BELL_DATA(LU)
  42. C
  43. C
  44.       END
  45. C
  46. C    >**************************************************************
  47.       SUBROUTINE GET_BELL_DATA(LU)
  48. C     **************************************************************
  49. C     SUBROUTINE TO PROMPT USER FOR INTEGER VALUE...
  50. C     --------------------------------------------------------------
  51. C     AUTHOR: JOHN L. BRADBERRY         CREATION DATE: FEB 8,1989
  52. C
  53.       IMPLICIT NONE
  54. C
  55.       INCLUDE 'BELLCOM.INC'
  56. C
  57. C
  58.       INTEGER*2         I               !LOOP INDEX COUNTER
  59.       INTEGER*2         LU              !LOGICAL UNIT NUMBER
  60.       INTEGER*2         BCCOUNT         !BELL CURVE DATA POINT COUNT
  61. C
  62. C
  63.       BCCOUNT=1
  64.       DO WHILE (BCCOUNT.GT.0)
  65. C
  66.         CALL IPROMPT(LU,'Enter Number Of Occurrences Next Data Point '//
  67.      +                  'Value (Or 0 To Exit).',BCCOUNT)
  68.       
  69.         IF (BCCOUNT.GT.0) THEN
  70.           CALL DRPROMPT(LU,'Enter Data Point Value (Range 0-100):',
  71.      +                  BCDAT)
  72.         END IF
  73. C
  74.         IF (BCCOUNT.GT.0) THEN
  75.           DO I=1,BCCOUNT
  76.             BCIDX=BCIDX+1
  77.             BCTOT=BCTOT+BCDAT
  78.           END DO
  79.           BCEX=BCEX+BCCOUNT*BCDAT
  80.           BCEXS=BCEXS+BCCOUNT*BCDAT*BCDAT
  81.         END IF
  82.       END DO
  83. C
  84. C
  85.  
  86.       RETURN
  87.       END
  88. C
  89. C    >**************************************************************
  90.       SUBROUTINE PLOT_BELL_DATA(LU)
  91. C     **************************************************************
  92. C     SUBROUTINE TO PROMPT USER FOR INTEGER VALUE...
  93. C     --------------------------------------------------------------
  94. C     AUTHOR: JOHN L. BRADBERRY         CREATION DATE: FEB 8,1989
  95. C
  96.       IMPLICIT NONE
  97. C
  98.       INCLUDE 'BELLCOM.INC'
  99. C
  100. C
  101.       INTEGER*2         LU              !LOGICAL UNIT NUMBER
  102.       INTEGER*2         KX              !LOOP INDEX COUNTER
  103.       INTEGER*2         STARCOUNT       !NUMBER OF STARS TO OUTPUT IN BELL
  104.       INTEGER*2         MAXSTARS        !MAXIMUM STARS IN CHARACTER STRING
  105.       
  106.       PARAMETER         (MAXSTARS=51)        
  107.       
  108.       CHARACTER         STARS*51        !STRING 'STAR' ARRAY
  109.             
  110.       REAL*8            RVAL1           !TEMPORARY
  111.       REAL*8            RVAL2           !TEMPORARY
  112.       REAL*8            DEGRAD          !DEGREES TO RADIAN CONVERSION
  113. C
  114. C
  115.       STARS='***************************************************'
  116. C
  117.       DEGRAD=3.141592654D0/180D0
  118. C     
  119.       IF (BCIDX.GT.0) THEN
  120.         BCEX=BCEX/BCIDX
  121.         BCEXS=BCEXS/BCIDX
  122.         BCMEAN=BCEX
  123.         BCVAR=BCEXS-BCEX*BCEX
  124.         BCSIGMA=SQRT(BCVAR)
  125.       END IF
  126. C
  127. C     BELL CURVE FORMULA...
  128. C     
  129. C     1/(SIGMA(SQRT(2PI)))*EXP(-(X-MEAN)**2/(2*SIGMA))
  130. C
  131.       RVAL1=1.0/(BCSIGMA*SQRT(2*3.141592654))
  132.       DO KX=0,100,5
  133.         RVAL2=RVAL1*EXP(-1.0*((KX-BCMEAN)**2)/(2.0*BCSIGMA*BCSIGMA))
  134.         RVAL2=1000*RVAL2
  135.  
  136.         STARCOUNT=MIN(NINT(RVAL2),MAXSTARS)
  137.         WRITE(LU,*)KX,' |',STARS(1:STARCOUNT)
  138.       END DO
  139. C
  140.       WRITE(LU,'(/,1X,A10,I2,2X,3(A10,F8.3,2X))')
  141.      +      '# POINTS= ',BCIDX,'MEAN= ',BCMEAN,'VARIANCE= ',
  142.      +      BCVAR,'   SIGMA= ',BCSIGMA
  143. C
  144. C
  145.       RETURN
  146.       END
  147. C
  148. C    >**************************************************************
  149.       SUBROUTINE IPROMPT(LU,PROMPT,IVAL)
  150. C     **************************************************************
  151. C     SUBROUTINE TO PROMPT USER FOR INTEGER VALUE...
  152. C     --------------------------------------------------------------
  153. C     AUTHOR: JOHN L. BRADBERRY         CREATION DATE: FEB 8,1989
  154. C
  155.       IMPLICIT NONE
  156. C
  157.       INTEGER*2         IVAL            !INTEGER VALUE RETURNED
  158.       INTEGER*2         LU              !LOGICAL UNIT NUMBER
  159. C
  160.       CHARACTER*(*)     PROMPT          !STRING PROMPT TO BE ISSUED
  161. C
  162. C
  163.       WRITE(LU,*)PROMPT
  164.       READ(LU,*)IVAL
  165. C
  166. C
  167.       RETURN
  168.       END
  169. C
  170. C
  171. C    >**************************************************************
  172.       SUBROUTINE DRPROMPT(LU,PROMPT,DRVAL)
  173. C     **************************************************************
  174. C     SUBROUTINE TO PROMPT USER FOR DOUBLE PRECISION REAL VALUE...
  175. C     --------------------------------------------------------------
  176. C     AUTHOR: JOHN L. BRADBERRY         CREATION DATE: FEB 8,1989
  177. C
  178.       IMPLICIT NONE
  179. C
  180.       INTEGER*2         LU              !LOGICAL UNIT NUMBER
  181. C
  182.       CHARACTER*(*)     PROMPT          !STRING PROMPT TO BE ISSUED
  183.  
  184. C
  185.       REAL*8            DRVAL           !REAL VALUE RETURNED
  186. C
  187. C
  188.       WRITE(LU,*)PROMPT
  189.       READ(LU,*)DRVAL
  190. C
  191. C
  192.       RETURN
  193.       END
  194. C
  195.  
  196. [LISTING TWO]
  197.  
  198.  
  199. C     -----------------------------------------------------------
  200. C     BELL CURVE CONTROL COMMON ...
  201. C     -----------------------------------------------------------
  202. C
  203.       INTEGER*2         BCIDX           !BELL CURVE INDEX
  204. C      
  205.       REAL*8            BCMEAN          !BELL CURVE MEAN
  206.       REAL*8            BCEX            !BELL CURVE EX TERM
  207.       REAL*8            BCEXS           !BELL CURVE EX TERM SQUARED
  208.       REAL*8            BCTOT           !BELL CURVE TOTAL
  209.       REAL*8            BCDAT           !BELL CURVE DATA
  210.       REAL*8            BCVAR           !BELL CURVE VARIANCE
  211.       REAL*8            BCSIGMA         !BELL CURVE SIGMA
  212. C
  213. C
  214.       COMMON /BELLCURVE/
  215. C
  216.      +BCIDX,
  217.      +BCMEAN,
  218.      +BCEX,
  219.      +BCEXS,
  220.      +BCTOT,
  221.      +BCDAT,
  222.      +BCVAR,
  223.      +BCSIGMA
  224. C
  225.  
  226.  
  227.  
  228. [Example 1]
  229.  
  230. C
  231.       INTEGER           GLU             !LOGICAL UNIT NUMBER
  232. C
  233.       GLU=10
  234.       OPEN (UNIT=GLU, FILE = 'USER')
  235. .
  236. .     (see listings 1-2 for rest of body)
  237. .
  238. C
  239.       CLOSE (GLU, STATUS = 'KEEP')
  240. C
  241.  
  242.  
  243.